home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / diskutil / multicop.lzh / MULTICOP.FOR next >
Encoding:
Text File  |  1993-09-23  |  29.6 KB  |  973 lines
  1. C       MULTICOP.FOR
  2. C               MULTICOP
  3. C               ESKIP
  4. C               FMTCOP
  5. C               ERROR
  6. C               SETSTA
  7. C               FEXIT
  8. C               AESSET
  9. C               DOFORM
  10. C----------------------------------------------------------------------
  11. C                                  MULTICOP
  12. C----------------------------------------------------------------------
  13. C
  14. C       Program to fast format and copy to disks
  15. C
  16. C       Read returns:
  17. C       A       Initial entry
  18. C       B       Abort read
  19. C       C       Read error
  20. C       D       Return form write form: write done
  21. C       E       Exit from write form
  22. C       F       End of HELP/ABORT
  23. C       G       Boot block error
  24. C       H       SPT/NTRACK error
  25. C
  26. C----------------------------------------------------------------------
  27. C
  28.         PROGRAM MULTICOP
  29.         INCLUDE 'MULTICOP.INC'
  30.         INCLUDE 'MULTICOP.JNC'
  31.            
  32. C   Local
  33.  
  34.         INTEGER*1 BNSTR(12),PKR1
  35.         INTEGER*2 LINE(0:3),DL(0:7),PKR2(2)
  36.         INTEGER*4 form_do,form_alert,objc_state
  37.         INTEGER*4 I,J,K,K1,K2,XX,XXX,RES,RDRV,WDRV,NDRV,HANDLE
  38.         INTEGER*4 EVENT,evnt_multi,objc_find,PMX,PMY,PMB,PKS,PKR,PBR
  39.         INTEGER*4 IADSEC,NTRACK,ITRACK,IH,IS,IM,IDN,NN
  40.         INTEGER*4 PX,PY,CXA(0:1),CYA(0:1)
  41.         INTEGER*4 STATE(0:1)
  42.         CHARACTER NAME*8,NSTR*12,ZERO*1
  43.         CHARACTER*7 DISK(0:1)
  44.         EQUIVALENCE (BNSTR,NSTR),(PKR2,PKR),(PKR2(2),PKR1)
  45.  
  46. C   Form parameters
  47.  
  48.         INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
  49.         COMMON /FRM/OBJADD,FX,FY,FW,FH
  50.         
  51.         INTEGER*4 CADD,FADD,CX,CY,CW,CH,X,Y,W,H
  52.         INTEGER*4 IBUT,HBUT
  53.         EQUIVALENCE (CADD,OBJADD(0)),(FADD,OBJADD(1))
  54.         EQUIVALENCE (CX,FX(0)),(X,FX(1))
  55.         EQUIVALENCE (CY,FY(0)),(Y,FY(1))
  56.         EQUIVALENCE (CW,FW(0)),(W,FW(1))
  57.         EQUIVALENCE (CH,FH(0)),(H,FH(1))
  58.         
  59.         INTEGER*1 SECTOR0(512,20,85),BUF(10000),BTBK(512)
  60.         INTEGER*1 SECTOR1(512,20,85)
  61.         INTEGER*4 SPT,SPD,NSIDES
  62.         INTEGER*4 WW,D1,D2,D3,D4,D5,D6,D7,D8,D9,D10,D11
  63.         INTEGER*4 CDA1,CDA2,CDA3,CDA4,CDA5,CDA6,CDA7
  64.         INTEGER*4 CDA8,CDA9,CDA10,CDA11
  65.         INTEGER*4 CDB1,CDB2,CDB3,CDB4,CDB5,CDB6,CDB7
  66.         INTEGER*4 CDB8,CDB9,CDB10,CDB11
  67.         EQUIVALENCE (SECTOR0,BTBK)
  68.         LOGICAL*4 RANNUM
  69.         
  70.         DATA NAME/'MULTICOP'/
  71.         DATA DISK/'Disk A ','Disk B '/
  72.  
  73.         ZERO=CHAR(0)
  74.         DISK(0)(7:7)=ZERO
  75.         DISK(1)(7:7)=ZERO
  76.                   
  77. C-------------------------------------------------------------MULTICOP
  78.  
  79. C   Formats
  80.  
  81. 1       FORMAT(I1)
  82. 2       FORMAT(I2)
  83. 4       FORMAT(I4)
  84. 10      FORMAT(I10)
  85.  
  86. C   Initialise AES
  87.  
  88.         CALL AESSET(HANDLE,NAME,-1,RES,OBJADD,FX,FY,FW,FH)
  89.         CALL graf_mouse(0,0)
  90.         CALL graf_mouse(256,0)                  !hide mouse
  91.         CALL objc_offset(FADD,READBAR,PX,PY)
  92.         CALL objc_offset(CADD,BARA,CXA(0),CYA(0))                
  93.         CALL objc_offset(CADD,BARB,CXA(1),CYA(1))
  94.  
  95. C   Initialise states
  96.  
  97.         CALL objc_read(FADD,READBAR,D1,D2,D3,D4,D5,D6,D7,
  98.      1                              D8,D9,D10,D11)
  99.         CALL objc_read(CADD,BARA,CDA1,CDA2,CDA3,CDA4,CDA5,CDA6,CDA7,
  100.      1                           CDA8,CDA9,CDA10,CDA11)
  101.         CALL objc_read(CADD,BARB,CDB1,CDB2,CDB3,CDB4,CDB5,CDB6,CDB7,
  102.      1                           CDB8,CDB9,CDB10,CDB11)
  103.      
  104. C   Start with mouse showing
  105.  
  106.         CALL graf_mouse(257,0)
  107.  
  108. C-------------------------------------------------------------------
  109. C                              Set up read form
  110.  
  111. C   Define read form;  hide mouse
  112.  
  113. 2000    CALL form_dial(0,0,0,0,0,X,Y,W,H)       !open dialog box
  114.  
  115. C   Hide mouse & clear read statistics and read button
  116.  
  117.         CALL ESKIP(0,1,*2100)               !Type A return
  118.  
  119. C   Draw read form
  120.  
  121. 2100    CALL objc_draw(FADD,0,32767,X,Y,W,H)
  122.         
  123. C--------------------------------------------------------------------
  124. C                       Process read form
  125.  
  126. 1000    CALL graf_mouse(257,0)
  127.         IBUT=form_do(FADD,0)
  128.         CALL graf_mouse(256,0)
  129.         IF (IBUT.NE.READIT)
  130.      1    CALL objc_change(FADD,IBUT,0,X,Y,W,H,0,.TRUE.)
  131.             
  132. C   Analyse exits
  133. C   Abort
  134.  
  135.         IF (IBUT.EQ.EXITR) THEN
  136.           CALL FEXIT(HANDLE,X,Y,W,H)
  137.  
  138. C   Give help
  139.  
  140.         ELSE IF (IBUT.EQ.HELP) THEN
  141.           CALL form_dial(3,0,0,0,0,X,Y,W,H)       !close box
  142.           CALL DOFORM(2,HBUT,0)
  143.           IF (HBUT.EQ.MORE) CALL DOFORM(3,HBUT,0)
  144.           CALL form_dial(0,0,0,0,0,X,Y,W,H)
  145.           CALL objc_draw(FADD,0,32767,X,Y,W,H)
  146.           GOTO 1000                               !Type F return
  147.  
  148. C   Abort
  149.  
  150.         ELSE IF (IBUT.EQ.ABORTR) THEN
  151.           GOTO 1000                               !rType F return
  152.           
  153. C   Read the disk
  154.         
  155.         ELSE
  156.   
  157.       
  158. C   Get the disk
  159.  
  160.           RDRV=objc_state(FADD,DISKB)
  161.  
  162. C   Read the disk number flag
  163.  
  164.           RANNUM=(objc_state(FADD,YESDN).GT.0)
  165.           
  166. C   Read boot block of master disk
  167.  
  168.           CALL FLOPRD(K,BTBK,RDRV,1,0,0,1)
  169.           IF (K.NE.0) THEN
  170.             I=form_alert(1,'[3][Error in boot block][Abort]')
  171.             CALL objc_change(FADD,IBUT,0,X,Y,W,H,0,.TRUE.)
  172.             GOTO 1000                           !Type G return
  173.           END IF
  174.           
  175.           IADSEC=IADDR(SECTOR0)
  176.  
  177. C   Get Sectors/track: SPT
  178.          
  179.           K1=(IPEEK1(IADSEC+25).AND.255)
  180.           CALL ISHFT(K1,K1,8)
  181.           K2=(IPEEK1(IADSEC+24).AND.255)
  182.           SPT=(K1.OR.K2)
  183.  
  184. C   Get sectors/disk: SPD
  185.  
  186.           K1=(IPEEK1(IADSEC+20).AND.255)
  187.           CALL ISHFT(K1,K1,8)
  188.           K2=(IPEEK1(IADSEC+19).AND.255)
  189.           SPD=(K1.OR.K2)
  190.  
  191. C   Get number of sides: NSIDES
  192.  
  193.           K1=(IPEEK1(IADSEC+27).AND.255)
  194.           CALL ISHFT(K1,K1,8)
  195.           K2=(IPEEK1(IADSEC+26).AND.255)
  196.           NSIDES=(K1.OR.K2)
  197.  
  198. C   Get disk number
  199.  
  200.           I=BTBK(9).AND.255
  201.           J=BTBK(10).AND.255
  202.           K=BTBK(11).AND.255
  203.           IDN=K+256*(J+256*I)
  204.  
  205. C   Get number of tracks: NTRACK
  206.  
  207.           NTRACK=SPD/(SPT*NSIDES)
  208.  
  209. C   Display some statistics
  210. C   First drive name
  211.  
  212.           CALL objc_newtext(FADD,SOURCE,DISK(RDRV))
  213.           CALL objc_draw(FADD,SOURCE,0,X,Y,W,H)
  214.           
  215. C   Sectors/track
  216.  
  217.           WRITE(NSTR(1:2),2) SPT
  218.           BNSTR(3)=0
  219.           CALL objc_newtext(FADD,SPTT,NSTR)
  220.           CALL objc_draw(FADD,SPTT,32767,X,Y,W,H)
  221.  
  222. C   Sectors/disk
  223.  
  224.           WRITE(NSTR(1:4),4) SPD
  225.           BNSTR(5)=0
  226.           CALL objc_newtext(FADD,SPDT,NSTR)
  227.           CALL objc_draw(FADD,SPDT,0,X,Y,W,H)
  228.  
  229. C   Sides/disk
  230.           
  231.           WRITE(NSTR(1:1),1) NSIDES
  232.           BNSTR(2)=0
  233.           CALL objc_newtext(FADD,SIPDT,NSTR)
  234.           CALL objc_draw(FADD,SIPDT,0,X,Y,W,H)
  235.  
  236. C   Tracks/side
  237.  
  238.           WRITE(NSTR(1:2),2) NTRACK
  239.           BNSTR(3)=0
  240.           CALL objc_newtext(FADD,TDDT,NSTR)
  241.           CALL objc_draw(FADD,TDDT,0,X,Y,W,H)
  242.  
  243. C   Test SPT and NTRACK
  244.  
  245.           IF (SPT.GT.11.OR.NTRACK.GT.85) THEN
  246.             IF (SPT.GT.11)
  247.      1        I=form_alert(1,'[3][Too many sectors/track][Abort]')
  248.             IF (NTRACK.GT.85)
  249.      1        I=form_alert(1,'[3][Too many tracks][Abort]')
  250.             CALL ESKIP(1,0,*1000)            !Type H return
  251.           END IF  
  252.  
  253. C   Disk #
  254.  
  255.           WRITE(NSTR(1:10),10) IDN
  256.           BNSTR(11)=0
  257.           CALL objc_newtext(FADD,DISKN,NSTR)
  258.           CALL objc_draw(FADD,DISKN,0,X,Y,W,H)
  259.           
  260.           IF (RANNUM) THEN
  261.             CALL TIME(IH,IM,IS,IH)
  262.             XX=RANDOM(IM*60+IS)
  263.           END IF
  264.  
  265. C   Set up progress bar X coordinate and box size
  266.  
  267.           WW=2*NTRACK+1
  268.           IF (WW.NE.D10) THEN
  269.             CALL objc_write(FADD,READBAR,D1,D2,D3,D4,D5,D6,D7,
  270.      1                                   D8,D9,WW-2,D11)
  271.             CALL objc_draw(FADD,READBAR,0,X,Y,W,H)          
  272.             CALL objc_write(CADD,BARA,CDA1,CDA2,CDA3,CDA4,CDA5,CDA6,
  273.      1                      CDA7,CDA8,CDA9,WW,CDA11)
  274.             CALL objc_write(CADD,BARB,CDB1,CDB2,CDB3,CDB4,CDB5,CDB6,
  275.      1                      CDB7,CDB8,CDB9,WW,CDB11)
  276.           END IF      
  277.  
  278. C   OK, Read in entire disk looping over tracks but testing 
  279. C   for an abort at each track
  280.  
  281.           NN=0                          !count of done copies
  282.           XXX=PX+1                      !X coordinate of progress bar
  283.           LINE(1)=PY
  284.           LINE(3)=PY+D11-1
  285.           CALL graf_mouse(257,0)        !show the mouse
  286.           
  287.           DO 400 ITRACK=0,NTRACK-1
  288.             EVENT=evnt_multi(35,1,1,1,
  289.      1                       0,0,0,0,0,0,0,0,0,0,DL,
  290.      2                       1,PMX,PMY,PMB,PKS,PKR,PBR)
  291.             IF (EVENT.NE.32) THEN
  292.               IF ((EVENT.AND.1).EQ.1) THEN
  293.                 IF (PKR1.EQ.1) CALL ESKIP(1,1,*1000)   !ESC: Type B return  
  294.               ELSE IF ((EVENT.AND.2).EQ.2) THEN
  295.                 I=objc_find(FADD,ABORTR,0,PMX,PMY)
  296.                 IF (I.EQ.ABORTR) CALL ESKIP(1,1,*1000) !abrt: Type B return    
  297.               END IF  
  298.             END IF
  299.             
  300. C   Read side 1
  301.  
  302.             CALL FLOPRD(K,SECTOR0(1,1,ITRACK+1),RDRV,1,ITRACK,0,SPT)
  303.             IF (K.NE.0) THEN
  304.               CALL ERROR(1,K,ITRACK,1)
  305.               CALL ESKIP(1,1,*1000)       !Type C return
  306.             END IF
  307.  
  308. C   Read side 2 if NSIDES=2
  309.  
  310.             IF (NSIDES.EQ.2) THEN
  311.               CALL FLOPRD(J,SECTOR1(1,1,ITRACK+1),RDRV,1,ITRACK,1,SPT)
  312.               IF (K.NE.0) THEN
  313.                 CALL ERROR(1,J,ITRACK,2)
  314.                 CALL ESKIP(1,1,*1000)       !Type C return
  315.               END IF
  316.             END IF
  317.  
  318. C   Draw a vertical line in the progess bar
  319.             
  320.             LINE(0)=XXX
  321.             LINE(2)=XXX
  322.             CALL v_pline(HANDLE,2,LINE)
  323.             XXX=XXX+2
  324.             
  325. 400       CONTINUE
  326.         END IF 
  327.  
  328. C   The master disk has been read
  329. C   Close form 2 (leave mouse showing)
  330.  
  331.         CALL objc_newstate(FADD,IBUT,0)
  332.         CALL form_dial(3,0,0,0,0,X,Y,W,H)       !close FADD
  333.  
  334. C---------------------------------------------------------------------
  335. C                             Format/Write form (0)
  336.  
  337. C   Initialise states in form 1 (the mouse still shows)
  338.  
  339.         CALL SETSTA(STATE,0,1)
  340.         CALL SETSTA(STATE,1,1)
  341.         CALL objc_newtext(CADD,TOTCOP,'0'//ZERO)
  342.  
  343. C   Open and draw form 1 (FM=0)
  344.  
  345.         CALL form_dial(0,0,0,0,0,CX,CY,CW,CH)
  346.         CALL objc_draw(CADD,0,32767,CX,CY,CW,CH)
  347.         
  348. C   Wait for A or B
  349.  
  350.         NDRV=-1
  351. 510     EVENT=evnt_multi(3,1,1,1,
  352.      1                   0,0,0,0,0,0,0,0,0,0,DL,
  353.      2                   1,PMX,PMY,PMB,PKS,PKR,PBR)
  354.  
  355. C   A keypress
  356.        
  357.         IF ((EVENT.AND.1).EQ.1) THEN
  358.           IF (PKR1.EQ.28) THEN               !RETURN: Back to form 1
  359.             GOTO 3000                           !Type E return
  360.           ELSE IF (PKR1.EQ.30.OR.PKR1.EQ.48) THEN
  361.             WDRV=IDIM(PKR1-47,0)             !A/B
  362.             CALL SETSTA(STATE,WDRV,3)
  363.           ELSE
  364.             GOTO 510
  365.           END IF            
  366.  
  367. C   A mouse click
  368.  
  369.         ELSE IF ((EVENT.AND.2).EQ.2) THEN
  370.           IF (objc_find(CADD,EXIT,0,PMX,PMY).EQ.EXIT) THEN
  371.             GOTO 3000                           !Type E return
  372.           ELSE IF (objc_find(CADD,DRIVEA,0,PMX,PMY).EQ.DRIVEA) THEN
  373.             WDRV=0
  374.             CALL SETSTA(STATE,WDRV,3)           !Drive A button
  375.           ELSE IF (objc_find(CADD,DRIVEB,0,PMX,PMY).EQ.DRIVEB) THEN
  376.             WDRV=1
  377.             CALL SETSTA(STATE,WDRV,3)           !Drive B button
  378.           ELSE
  379.             GOTO 510
  380.           END IF            
  381.         END IF  
  382.  
  383. C   Write to disk WDRV  
  384.  
  385.         IF (WDRV.EQ.0.OR.WDRV.EQ.1) THEN
  386. 520       I=CYA(WDRV)
  387.           LINE(0)=CXA(WDRV)+1
  388.           LINE(1)=I
  389.           LINE(3)=I+CDA11-1
  390.  
  391.           CALL FMTCOP(SECTOR0,SECTOR1,BUF,BTBK,
  392.      1                      SPT,NSIDES,WDRV,NDRV,NTRACK,
  393.      2                      RANNUM,HANDLE,LINE,STATE,NN,IDN)
  394.           IF (NDRV.NE.-1) THEN          !there is a disk ready
  395.             WDRV=NDRV
  396.             NDRV=-1
  397.             GOTO 520
  398.           ELSE                          !no disks ready
  399.             GOTO 510
  400.           END IF  
  401.         END IF
  402.         CALL BELL
  403.              
  404. C   Close CADD form; return for another lot
  405.  
  406. 3000    CALL objc_newstate(CADD,IBUT,0)
  407.         CALL form_dial(3,0,0,0,0,CX,CY,CW,CH)
  408.  
  409. C   Return with mouse showing and all forms closed
  410.  
  411.         GOTO 2000                               !Type D return
  412.         END
  413.  
  414. C-------------------------------------------------------------------
  415. C                              ESKIP                
  416. C-------------------------------------------------------------------
  417. C
  418. C       Subroutine to tidyup after a read abort or error by:
  419. C       1.      If MSE is true, Hiding mouse
  420. C       2.      Deselecting READIT button
  421. C       3       Redrawing READIT is DRAW is true
  422. C       4.      Clearing read stats
  423. C       5       Redrawing stats if DRAW is true
  424. C
  425. C-------------------------------------------------------------------
  426.  
  427.         SUBROUTINE ESKIP(DRAW,MSE,*)
  428.         INCLUDE 'MULTICOP.INC'
  429.         INCLUDE 'MULTICOP.JNC'
  430.         
  431.         INTEGER*4 DRAW,MSE
  432.         
  433.         INTEGER*4 I,STATS(6),STL(6)
  434.         LOGICAL*4 BDRAW
  435.         CHARACTER BLANK*12,ZERO*1
  436.         
  437.  
  438.         INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
  439.         COMMON /FRM/OBJADD,FX,FY,FW,FH
  440.         INTEGER*4 FADD,X,Y,W,H
  441.         EQUIVALENCE (FADD,OBJADD(1))
  442.         EQUIVALENCE (X,FX(1))
  443.         EQUIVALENCE (Y,FY(1))
  444.         EQUIVALENCE (W,FW(1))
  445.         EQUIVALENCE (H,FH(1))
  446.         
  447.         DATA BLANK/'            '/
  448.         DATA STATS/SPTT,SPDT,SIPDT,TDDT,DISKN,SOURCE/
  449.         DATA STL/2,4,1,2,10,7/
  450.         
  451.         ZERO=CHAR(0)
  452.         
  453. C--------------------------------------------------------------ESKIP
  454.  
  455.         BDRAW=(DRAW.EQ.1)
  456.         IF (MSE.EQ.1) THEN
  457.           CALL graf_mouse(256,0)          !hide mouse
  458.           IF (BDRAW) CALL objc_draw(FADD,READBAR,0,X,Y,W,H)
  459.         END IF  
  460.         DO 200 I=1,6
  461.           CALL objc_newtext(FADD,STATS(I),BLANK(1:STL(I))//ZERO)
  462.           IF (BDRAW) CALL objc_draw(FADD,STATS(I),0,X,Y,W,H)
  463. 200     CONTINUE
  464.         CALL objc_change(FADD,READIT,0,X,Y,W,H,0,BDRAW)  
  465.         RETURN 1        
  466.         END
  467.  
  468.         
  469. C---------------------------------------------------------------------
  470. C                              FMTCOP
  471. C---------------------------------------------------------------------
  472. C
  473. C       Subroutine to copy/format a disk in drive WDRV
  474. C
  475. C       WDRV  Current working drive A=0, B=1
  476. C
  477. C       The mouse shows throughout this routine.
  478. C       The form (CADD) is neither opened or closed
  479. C
  480. C---------------------------------------------------------------------
  481.  
  482.         SUBROUTINE FMTCOP(SECTOR0,SECTOR1,BUF,BTBK,
  483.      1                    SPT,NSIDES,WDRV,NDRV,NTRACK,
  484.      2                    RANNUM,HANDLE,LINE,STATE,NN,IDN)
  485.         INCLUDE 'MULTICOP.INC'
  486.         INCLUDE 'MULTICOP.JNC'
  487.  
  488.         INTEGER*1 SECTOR0(512,11,85),BUF(10000),BTBK(512)
  489.         INTEGER*1 SECTOR1(512,11,85)
  490.         INTEGER*4 SPT,NSIDES,WDRV,NDRV,NTRACK
  491.         INTEGER*4 HANDLE,STATE(0:1)
  492.         INTEGER*2 LINE(0:3)
  493.         INTEGER*4 NN,IDN
  494.         LOGICAL*4 RANNUM
  495.         
  496.         INTEGER*1 IB1,JB1,KB1,II1(4),JJ1(4),KK1(4)
  497.         INTEGER*4 I,J,K,JDN,ITRACK,IA,IB,BAR(0:1),XXX,KDRV,NEWS
  498.         INTEGER*4 EVENT,evnt_multi,objc_find,PMX,PMY,PMB,PKS,PKR,PBR
  499.         INTEGER*4 COPN(0:1),DISN(0:1)
  500.         INTEGER*2 DL(0:7),PKR2(2)
  501.         INTEGER*1 PKR1
  502.         CHARACTER STNN*4,STDIS*12,ZERO*1
  503.         EQUIVALENCE (PKR2,PKR),(PKR2(2),PKR1)
  504.         EQUIVALENCE (I,II1),(J,JJ1),(K,KK1)
  505.         EQUIVALENCE (IB1,II1(4)),(JB1,JJ1(4)),(KB1,KK1(4))       
  506.                              
  507. C   Form parameters
  508.  
  509.         INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
  510.         COMMON /FRM/OBJADD,FX,FY,FW,FH
  511.         
  512.         INTEGER*4 CADD,CX,CY,CW,CH
  513.         EQUIVALENCE (CADD,OBJADD(0))
  514.         EQUIVALENCE (CX,FX(0))
  515.         EQUIVALENCE (CY,FY(0))
  516.         EQUIVALENCE (CW,FW(0))
  517.         EQUIVALENCE (CH,FH(0))
  518.  
  519.         DATA COPN/COPNA,COPNB/
  520.         DATA DISN/DISKNA,DISKNB/
  521.         DATA BAR/BARA,BARB/
  522.         
  523.         ZERO=CHAR(0)
  524.         STNN(4:4)=ZERO
  525.         STDIS(11:11)=ZERO
  526.  
  527. C---------------------------------------------------------------FMTCOP
  528.  
  529. C   Formats
  530.  
  531. 1       FORMAT(I1)
  532. 2       FORMAT(I2)
  533. 3       FORMAT(I3)
  534. 10      FORMAT(I10)
  535.         
  536. C   Put random disk number in BTBK if required
  537.  
  538.         IF (RANNUM) THEN
  539.           I=IFIX(256.*RANDOM(0)).AND.255
  540.           J=IFIX(256.*RANDOM(0)).AND.255
  541.           K=IFIX(256.*RANDOM(0)).AND.127
  542.           JDN=K+256*(J+256*K)
  543.           BTBK(9)=IB1                           !L606=446+160
  544.           BTBK(10)=JB1
  545.           BTBK(11)=KB1
  546.         ELSE
  547.           JDN=IDN
  548.         END IF  
  549.  
  550. C   Clear bar & initialise
  551.  
  552.         CALL objc_draw(CADD,BAR(WDRV),0,CX,CY,CW,CH)
  553.         XXX=LINE(0)
  554.  
  555. C   Reset state to working
  556.  
  557.         CALL SETSTA(STATE,WDRV,3)
  558.         
  559. C   Set up for formatting and copying
  560.  
  561.         NEWS=4                                      !default done flag
  562.         NN=NN+1                                     !increment copy count
  563.  
  564. C   Enter and draw copy # and disk #
  565.  
  566.         WRITE(STNN(1:3),3) NN
  567.         CALL objc_newtext(CADD,COPN(WDRV),STNN)
  568.         CALL objc_draw(CADD,COPN(WDRV),0,CX,CY,CW,CH)
  569.         WRITE(STDIS(1:10),10) JDN                   !disk number
  570.         CALL objc_newtext(CADD,DISN(WDRV),STDIS)
  571.         CALL objc_draw(CADD,DISN(WDRV),0,CX,CY,CW,CH)
  572.         
  573. C   Format and copy track by track
  574.  
  575.         DO 300 ITRACK=0,NTRACK-1
  576.         
  577. C   Get an instruction to abort or ready a drive
  578.  
  579.             EVENT=evnt_multi(35,1,1,1,
  580.      1                       0,0,0,0,0,0,0,0,0,0,DL,
  581.      2                       1,PMX,PMY,PMB,PKS,PKR,PBR)
  582.  
  583. C   A keypress
  584.  
  585.             IF (EVENT.NE.32) THEN
  586.               IF ((EVENT.AND.1).EQ.1) THEN
  587.                 IF (PKR1.EQ.1) THEN               !ESC: Abort
  588.                   NEWS=6
  589.                   GOTO 500
  590.                 ELSE IF (PKR1.EQ.30.OR.PKR1.EQ.48.AND.NDRV.EQ.-1) THEN
  591.                   KDRV=IDIM(PKR1-47,0)            !A/B: Ready a drive
  592.                   IF (STATE(KDRV).NE.3) THEN
  593.                     NDRV=KDRV
  594.                     CALL SETSTA(STATE,NDRV,2)  !A/B: ready it
  595.                   END IF
  596.                 END IF            
  597.  
  598. C   A mouse click
  599.  
  600.               ELSE IF ((EVENT.AND.2).EQ.2) THEN       !Abort
  601.                 IF (objc_find(CADD,RESET,0,PMX,PMY).EQ.RESET) THEN
  602.                   NEWS=6
  603.                   GOTO 500
  604.                 ELSE IF
  605.      1            (objc_find(CADD,DRIVEA,0,PMX,PMY).EQ.DRIVEA) THEN
  606.                   IF (STATE(0).NE.3) THEN
  607.                     NDRV=0
  608.                     CALL SETSTA(STATE,NDRV,2)  !Ready
  609.                   END IF
  610.                 ELSE IF
  611.      1            (objc_find(CADD,DRIVEB,0,PMX,PMY).EQ.DRIVEB) THEN
  612.                   IF (STATE(1).NE.3) THEN
  613.                     NDRV=1
  614.                     CALL SETSTA(STATE,NDRV,2)  !Ready
  615.                   END IF  
  616.                 END IF            
  617.               END IF
  618.             END IF    
  619.  
  620. C   Format side 1
  621.  
  622.           CALL FLPFMT(K,BUF,WDRV,SPT,ITRACK,0,0)
  623.           IF (K.NE.0) THEN
  624.             CALL ERROR(2,K,ITRACK,1)
  625.             NEWS=5                              !error flag
  626.             GOTO 500
  627.           END IF
  628.           
  629. C   Write SECTOR0 to it
  630.  
  631.           CALL FLOPWR(K,SECTOR0(1,1,ITRACK+1),WDRV,1,ITRACK,0,SPT)
  632.           IF (K.NE.0) THEN
  633.             CALL ERROR(3,K,ITRACK,1)
  634.             NEWS=5                              !error flag
  635.             GOTO 500
  636.           END IF
  637.  
  638. C   Format side 2 if NSIDES=2
  639.  
  640.           IF (NSIDES.EQ.2) THEN
  641.             CALL FLPFMT(K,BUF,WDRV,SPT,ITRACK,1,0)
  642.             IF (K.NE.0) THEN
  643.               CALL ERROR(2,K,ITRACK,2)
  644.               NEWS=5                            !error flag
  645.               GOTO 500
  646.             END IF
  647.  
  648. C   Write SECTOR1 to it
  649.  
  650.             CALL FLOPWR(K,SECTOR1(1,1,ITRACK+1),WDRV,1,ITRACK,1,SPT)
  651.             IF (K.NE.0) THEN
  652.               CALL ERROR(3,K,ITRACK,2)
  653.               NEWS=5                            !error flag
  654.               GOTO 500
  655.             END IF
  656.           END IF
  657.           
  658. C   Enter a progress bar
  659.         
  660.           LINE(0)=XXX
  661.           LINE(2)=XXX
  662.           CALL v_pline(HANDLE,2,LINE)
  663.           XXX=XXX+2
  664.  
  665. 300     CONTINUE
  666.         
  667. C   Reset state to done, empty or faulty and decrement 
  668.  
  669. 500     IF (NEWS.GE.5) NN=NN-1              !not done: abort/faulty
  670.         CALL SETSTA(STATE,WDRV,NEWS)        !done, aborted or faulty
  671.  
  672. C   Enter total copies made
  673.  
  674.         WRITE(STNN(1:3),3) NN
  675.         CALL BELL
  676.         CALL objc_newtext(CADD,TOTCOP,STNN)
  677.         CALL objc_draw(CADD,TOTCOP,0,CX,CY,CW,CH)
  678.  
  679.         END
  680.  
  681. C---------------------------------------------------------------------
  682. C                               ERROR
  683. C---------------------------------------------------------------------
  684. C
  685. C       Subroutine show form alert with error source
  686. C
  687. C---------------------------------------------------------------------
  688.  
  689.         SUBROUTINE ERROR(EN,K,TRACK,SIDE)
  690.  
  691.         INTEGER*4 EN,K,TRACK,SIDE
  692.         
  693.         INTEGER*4 I,form_alert
  694.         INTEGER*2 POS(3)
  695.         CHARACTER*52 STR(3)
  696.         CHARACTER ZERO*1
  697.         
  698.         DATA POS/16,22,19/
  699.         DATA STR/
  700.      1    '[3][Read error nnn|on track nn|side n][Abort]',
  701.      2    '[3][Formatting error nnn|on track nn|side n][Abort]',
  702.      3    '[3][Writing error nnn|on track nn|side n][Abort]'/
  703.         
  704.         ZERO=CHAR(0)
  705.         STR(1)(46:46)=ZERO   
  706.         STR(2)(52:52)=ZERO
  707.         STR(3)(49:49)=ZERO
  708.                      
  709. C----------------------------------------------------------------ERROR
  710.  
  711. 3       FORMAT(I3)
  712. 2       FORMAT(I2)
  713. 1       FORMAT(I1)
  714.         
  715.         I=POS(EN)
  716.         WRITE(STR(EN)(I:I+2),3) K
  717.         I=I+13
  718.         WRITE(STR(EN)(I:I+1),2) TRACK
  719.         I=I+8
  720.         WRITE(STR(EN)(I:I),1) SIDE
  721.         I=form_alert(1,STR(EN))
  722.  
  723.         END
  724.         
  725. C---------------------------------------------------------------------
  726. C                               SETSTA
  727. C---------------------------------------------------------------------
  728. C
  729. C       Subroutine to set the sate of drive DRV to state NEWSTA and
  730. C       draw text STATEX(NEWSTA) into object STAOBJ(DRIVE)
  731. C
  732. C---------------------------------------------------------------------
  733.  
  734.         SUBROUTINE SETSTA(STATE,DRIVE,NEWSTA)
  735.         INCLUDE 'MULTICOP.INC'
  736.         INCLUDE 'MULTICOP.JNC'
  737.              
  738.         INTEGER*4 STATE(0:1),DRIVE,NEWSTA
  739.         
  740.         INTEGER*4 KST,COP,DIS
  741.         INTEGER*4 STAOBJ(0:1),COPN(0:1),DISN(0:1),BARN(0:1)
  742.         CHARACTER*7 STATEX(6)
  743.         CHARACTER ZERO*1
  744.         INTEGER*1 BZERO
  745.         EQUIVALENCE (BZERO,ZERO)
  746.         
  747.         INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
  748.         COMMON /FRM/OBJADD,FX,FY,FW,FH
  749.  
  750.         INTEGER*4 CADD,CX,CY,CW,CH
  751.         EQUIVALENCE (CADD,OBJADD(0))
  752.         EQUIVALENCE (CX,FX(0)),(CY,FY(0)),(CW,FW(0)),(CH,FH(0))
  753.                 
  754.         DATA STAOBJ/STATEA,STATEB/
  755.         DATA STATEX/'Waiting','Ready  ','Working',
  756.      1              'Done   ','Faulty ','Aborted'/
  757.         DATA COPN/COPNA,COPNB/
  758.         DATA DISN/DISKNA,DISKNB/
  759.         DATA BARN/BARA,BARB/
  760.         DATA BZERO/0/
  761.         
  762. C----------------------------------------------------------------SETSTA
  763.  
  764.         STATE(DRIVE)=NEWSTA
  765.  
  766. C   Redraw status In all cases)
  767.  
  768.         KST=STAOBJ(DRIVE)
  769.         CALL objc_newtext(CADD,KST,STATEX(NEWSTA)//ZERO)
  770.         IF (NEWSTA.GT.1)  CALL objc_draw(CADD,KST,0,CX,CY,CW,CH)
  771.  
  772. C   Reset stats 
  773.         
  774.         IF (NEWSTA.LE.2) THEN
  775.           COP=COPN(DRIVE)
  776.           DIS=DISN(DRIVE)
  777.           CALL objc_newtext(CADD,COP,'   '//ZERO)
  778.           CALL objc_newtext(CADD,DIS,'          '//ZERO)
  779.  
  780. C   Redraw stats and bar for NEWSTA=2 only
  781.  
  782.           IF (NEWSTA.EQ.2) THEN
  783.             CALL objc_draw(CADD,COP,0,CX,CY,CW,CH)
  784.             CALL objc_draw(CADD,DIS,0,CX,CY,CW,CH)
  785.             CALL objc_draw(CADD,BARN(DRIVE),0,CX,CY,CW,CH)
  786.           END IF
  787.         END IF  
  788.         END
  789.         
  790. C---------------------------------------------------------------------
  791. C                               FEXIT
  792. C---------------------------------------------------------------------
  793. C
  794. C       Subroutine to close down form and AES and exit
  795. C
  796. C---------------------------------------------------------------------
  797.  
  798.         SUBROUTINE FEXIT(HANDLE,X,Y,W,H)
  799.         
  800.         INTEGER*4 HANDLE,X,Y,W,H
  801.         
  802. C----------------------------------------------------------------FEXIT
  803.  
  804.         CALL v_clsvwk(HANDLE)                   !close virtual work station
  805.         CALL form_dial(3,0,0,0,0,X,Y,W,H)       !close box
  806.         CALL rsrc_free                          !free tree memory
  807.         CALL graf_mouse(257,0)                  !show mouse as we exit
  808.         CALL appl_exit                          !exit AES
  809.         STOP
  810.         END
  811.        
  812. C------------------------------------------------------------------
  813. C                               AESSET
  814. C------------------------------------------------------------------
  815. C
  816. C       A subroutine for setting up AES applications
  817. C
  818. C       Input:
  819. C               NAME    Character string of .RSC name
  820. C               NMENU   I*4 Muenu object # or -1 if none
  821. C               NF      Highest form number
  822. C
  823. C       Output:
  824. C               RES     Resolution, 1 = medium; 2 = high
  825. C               OBJADD  Array of form addresses
  826. C               FX,FY   Arrays of form coordinates
  827. C               FW,FH   Arrays of form sizes
  828. C
  829. C       The object (form & menu) addresses are put in OBJADD
  830. C       and the cooerdinates in FX,FY,FW,FH
  831. C
  832. C------------------------------------------------------------------
  833.  
  834.         SUBROUTINE AESSET(HANDLE,NAME,NMENU,RES,OBJADD,FX,FY,FW,FH)
  835.         INCLUDE 'MULTICOP.JNC'
  836.                 
  837.         CHARACTER NAME*8
  838.         INTEGER*4 HANDLE,NMENU,RES
  839.         INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
  840.        
  841.         INTEGER*4 AESret,form_alert,graf_handle,dummy
  842.         INTEGER*2 work_in(0:10),work_out(0:56)
  843.         INTEGER*4 XBIOS
  844.         INTEGER*2 BUFFER(0:7)
  845.        
  846.         INTEGER*4 I,IBUT,L
  847.         
  848. C------------------------------------------------------------------
  849.  
  850. C   Initialise application with AES
  851.  
  852.         CALL appl_init
  853.         IF (AESret() .lt. 0) GOTO 999
  854.  
  855. C   Test resolution
  856.  
  857.         BUFFER(0)=4
  858.         L=LENGTH(NAME)
  859.         RES=XBIOS(BUFFER)
  860.         IF (RES.EQ.0) THEN
  861.           dummy=form_alert(1,'[3]['//NAME(1:L)//
  862.      1                       ' cannot be used in|'//
  863.      2                           'low resolution; change|'//
  864.      3                           'to medium and try again]'//
  865.      4                           '[OK]'//CHAR(0))
  866.           GOTO 998 
  867.         END IF       
  868.         
  869. C   Load resource file (must have extension)
  870.  
  871.         CALL rsrc_load(NAME(1:L)//'.RSC'//CHAR(0))
  872.         IF (AESret().EQ.0) THEN
  873.           DUMMY = form_alert(1, '[3]['//NAME(1:L)//
  874.      1                          '.RSC cannot be found]'//
  875.      2                          '[ OK ]' // char(0))
  876.           GOTO 998
  877.         END IF 
  878.  
  879. C   Get addresses and sizes of all forms
  880.  
  881.         DO 100 I=0,NF
  882.           CALL rsrc_gaddr(0,I,OBJADD(I))
  883.           IF (I.NE.NMENU) 
  884.      1      CALL form_center(OBJADD(I),FX(I),FY(I),FW(I),FH(I))
  885. 100     CONTINUE        
  886.         
  887. C   Get handle of desktop workstation
  888.  
  889.         HANDLE=graf_handle(dummy,dummy,dummy,dummy)
  890.  
  891. C   Initialise work_in
  892.           
  893.         work_in(0)=RES+2
  894.         DO 200 I=1,9
  895.           work_in(I)=1
  896. 200     CONTINUE
  897.         work_in(7)=0                    !fill style 0
  898.         work_in(10)=2                   !raster coordinates
  899.  
  900. C   Open a virtual workstation with handle of physical WS in HANDLE
  901. C     HANDLE is returned with new handle to VWS.
  902. C     work_out contains parameters of VWS
  903.  
  904.         CALL v_opnvwk(work_in,HANDLE,work_out)
  905.         IF (HANDLE.EQ.0) THEN
  906.           Dummy = form_alert(1, '[3][Error:'//
  907.      1                          '|Work station could not be opened]'//
  908.      1                          '[ OK ]' // char(0))
  909.           GOTO 997
  910.         END IF
  911. C   Return OK
  912.  
  913.         RETURN
  914.         
  915. C   Tidyup for anomalous exit and stop
  916.  
  917. 997     CALL rsrc_free                          !free tree memory
  918. 998     CALL appl_exit                          !exit AES
  919. 999     STOP
  920.         END
  921.         
  922. C----------------------------------------------------------------
  923. C                              DOFORM
  924. C----------------------------------------------------------------
  925. C   Subroutine to:
  926. C
  927. C       Reserve space for form of address FADD
  928. C       Display form
  929. C       Process form -  cursor first to object IFL
  930. C       Reset state of exit button
  931. C       Delete form space
  932. C
  933. C--------------------------------------------------------------DOFORM
  934.  
  935.         SUBROUTINE DOFORM(FN,IBUT,IFL)
  936.         INCLUDE 'MULTICOP.JNC'
  937.         
  938.         INTEGER*4 FN,IBUT,IFL
  939.        
  940.         INTEGER*4 I,form_do
  941.         
  942. C   Form data
  943.  
  944.         INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
  945.         COMMON /FRM/OBJADD,FX,FY,FW,FH
  946.         
  947.         INTEGER*4 FADD,X,Y,H,W
  948.  
  949. C----------------------------------------------------------------DOFORM
  950.  
  951. C   Get address and coordinates of form
  952.  
  953.         FADD=OBJADD(FN)
  954.         X=FX(FN)
  955.         Y=FY(FN)
  956.         W=FW(FN)
  957.         H=FH(FN)
  958.         
  959. C   Define area of form; draw the form; process form;
  960. C   restore exit button
  961.  
  962.         CALL form_dial(0,0,0,0,0,X,Y,W,H)
  963. 111     CALL objc_draw(FADD,0,32767,X,Y,W,H)
  964.         CALL graf_mouse(257,0)
  965.         IBUT=form_do(FADD,IFL)
  966.         CALL graf_mouse(256,0)
  967.         CALL objc_newstate(FADD,IBUT,0)
  968. 200     CALL form_dial(3,0,0,0,0,X,Y,W,H)
  969.                
  970.         END
  971.         
  972.  
  973.